Aminet 1

home *** CD-ROM | disk | FTP | other *** search

/ Aminet 1 / Aminet - June 1993 [Walnut Creek].iso / usenet / sources / volume90 / aplictns / dtc / part05 < prev next >

Wrap

Internet Message Format | 1990-03-14 | 41.1 KB

Path: xanth!cs.odu.edu!Amiga-Request From: Amiga-Request@cs.odu.edu (Amiga Sources/Binaries Moderator) Newsgroups: comp.sources.amiga Subject: v90i111: DTC - desktop calendar, Part05/06 Message-ID: <11790@xanth.cs.odu.edu> Date: 14 Mar 90 01:34:17 GMT Sender: tadguy@cs.odu.edu Reply-To: "Glenn Everhart: 215 354 7610 (8*747 7610)" <EVERHART@ARISIA.dnet.ge.com> Lines: 1546 Approved: tadguy@cs.odu.edu (Tad Guy) X-Mail-Submissions-To: Amiga@cs.odu.edu X-Post-Discussions-To: comp.sys.amiga Submitted-by: "Glenn Everhart: 215 354 7610 (8*747 7610)" <EVERHART@ARISIA.dnet.ge.com> Posting-number: Volume 90, Issue 111 Archive-name: applications/dtc/part05 #!/bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of archive 5 (of 6)." # Contents: Dtc.For.aa # Wrapped by tadguy@xanth on Tue Mar 13 20:29:28 1990 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'Dtc.For.aa' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Dtc.For.aa'\" else echo shar: Extracting \"'Dtc.For.aa'\" $38412 characters$ sed "s/^X//" >'Dtc.For.aa' <<'END_OF_FILE' XC -h- dtcvax.for Tue Jul 8 16:01:48 1986 Xc------------------------------------------------------------------------ XC Desk Top Calender Program XC Mitch Wyle 17.11.82 XC This program provides an on-line appointment calender system Xc for daily appointments, week-at-a-glance schedule, and month- Xc at-a-glance schedule. A facility is provided for a daily re- Xc minder. XC The program has help and menu prompting facilities for the new Xc user and the ability to interpret an MCR line for the experienced Xc user. The CRT screen functions are specific to the DEC VT-100 Xc screen terminal, as is the FORTRAN code. XC------------------------------------------------------------------------ XC Compile: XC------------------------------------------------------------------------ X Xc Declarations: X X include comdtc.INC XC Get common file X include escdtc.INC XC Frequently-used escape sequences X include appdtc.Inc Xc Initialize common declared above X include dtcxidate.inc X INTEGER*1 ln1 X Character*1 ln1c Xc first character of line X integer*2 ln2 X integer*1 incsel(4) X logical exflag XC first two characters of line X character*84 comlin X character*9 fnamech Xc character*60 fnamchh Xc character*18 fname XC Make FORTRAN OPEN happy X equivalence (comlin, line(1)) X equivalence (line(1),ln1) X equivalence (ln1, ln2) X Equivalence (ln1,ln1c) Xc equivalence (line(1),ln1) X equivalence (fname,fnamech) Xc equivalence (fnamchh,fname) X X character*2 khomescrn,kclrscrn,kdhdw1,kdhdw2, X 1 kdwide,kresetvattr,krevattr X Integer*4 kincmod X include stmtfuncsp.for X Data comlin /' '/ X Data fnamech /'DTC.DAT'/ XC Make FORTRAN OPEN happy XC Length of default value X include comdtcd.inc X include escdtcd.inc X data khomescrn /'[H'/, kclrscrn /'[J'/, X 1 kdhdw1 /'#3'/, kdhdw2 /'#4'/, kdwide /'#6'/, X 2 kresetvattr /'[m'/, krevattr /'[7m'/ X X data kincmod /1/ XC Default to day X Xc End common initialization X XC INCMOD will flag day/week/month/year default increment... Xc 1=day, 2=week, 3=month,4=year X Data incsel /'D', 'W', 'M', 'Y'/ XC Auto display after +/- X XC Integer*4 lib$get_foreign XC Get DCL command line, unparsed X X Data exflag/.false./ XC True if data on DCL command line X X include stmtfunc.for XC Get useful statement functions X Xc Begin code: X fname(18)=0 X fnsz=9 X comlen=0 X comidx=0 X homescrn=khomescrn X clrscrn=kclrscrn X dhdw1=kdhdw1 X dhdw2=kdhdw2 X dwide=kdwide X resetvattr=kresetvattr X revattr=krevattr X incmod=kincmod Xc Iterm=7 Xc first set up default data filename X Close(Unit=7) Xc ensure lun 7 closed in case it was pre-opened Xc Open new window for our operations Xc units seem to be PELs (we have 640 by 400 in interlace mode) X open(unit=7,file='CON:0/0/639/199/Desktop Calendar - H for Help' X 1 ,err=980) XC >>> Assumes VT100, interactive <<< X980 continue Xc Escape sequences used: XC <ESC>7 Save cursor and video attributes Xc <ESC>8 Restore ... Xc <ESC>< Exit ATS mode Xc <ESC>> Keypad numeric mode (Exit Alternate Keypad mode) Xc <ESC>[?4l Reset scroll mode (jump) Xc <ESC>[?6l Reset origin mode (absolute) Xc <ESC>[r Set top/bottom margins (default - 1:24) Xc <ESC>[m Graphic rendition = primary (default) Xc <ESC>[H Set cursor at home position (upper left) Xc <ESC>(B G0 (SI/^O) = US ASCII Xc <ESC>)0 G1 (SO/^N) = Special graphics Xc ^O Shift In (Select G0 (US ASCII)) X XC Clean up terminal XC [m X Rewind iterm X write (iterm,100) X 1 esc,'<', esc,'>', X 2 esc,'[?4l', esc,resetvattr, X 4 esc,'7', esc,'[?6l', esc,'[r', esc,'8' X write(iterm,100) esc,'[0;0H',esc,'[26t',esc,'[138u' Xc set private Amiga modes to inhibit wrap... Xc set so smallfont will (we hope) have all positions available. X Rewind iterm X 100 format ($, 21a, $) XC Escape sequences X ibigyr=1987 X iddy=4 X idmo=7 X call dtcidate(idmo,iddy,ibigyr) XC Get current date X call dtcicomd X Xc First time, get the MCR line, then parse and process it: X Xc INIT exflag=.false. XC Assume terminal input X XC istat=lib$get_foreign(comlin,,comlen) XC if ((istat .ne. ss$_normal) .or. (comlen .eq. 0)) XC 1 go to 77 X GOTO 77 Xc Allow for single operation to insert an appointment in upper & lower case X XC if (ln1 .eq. '"') then XC User quoted the line XC do (i = 2, comlen) XC First of many re-copy opns XC line(i-1) = line(i) XC copy it down XC end do XC comlen = comlen - 1 XC end if X XC line(min0(comlen+1, icmln)) = 0 XC Set end of line character XC exflag=.true. XC Flag for exit after one command X Xc Generalized parser and scanner routine for line: X X 1 continue XC Loop up here on any input. X Xc initialize flags to normal search display sense (show occupied times) Xc and no special meeting setups... X X rdspfg=0 X ctlfg=0 X X 1111 continue XC Re-enter here, after "+", etc X X comidx = 1 XC Initialize for parsing X X if (lcalpha(ln1)) X 1 ln1 = ln1 -32 XC Change to upper case Xc Find out what's seen in the line... X If ((ln1c .eq. 'D') X 1 .or. (ln1c .eq. '=') X 2 .or. (ln1c .eq. '*')) X 3 then X incmod=1 X call day XC (line) XC display daily, X go to 6 X X else if (ln1c .eq. 'W') X 1 then X incmod=2 X call week XC (line) XC weekly, X go to 6 X X else if (ln1c .eq. 'M') X 1 then X incmod=3 X call month XC (line) XC or monthly schedules, X go to 6 X X else if (ln1c .eq. 'Y') X 1 then X incmod=4 X call year XC (line) XC or full-year calendar X go to 6 X Xc flag multiple schedule of meeting to enable multi entry X else if (ln1c .eq. 'S') X 1 then X ln1c='D' X ctlfg=1 X incmod=1 X call day XC (line) X go to 6 X Xc use G as a schedule that will write appointments in current and Xc all indirected files. X else if (ln1c .eq. 'G') X 1 then X ln1c='D' X ctlfg=2 X incmod=1 X call day XC (line) X go to 6 X X else if ((ln1c .eq. '+') .or. (ln1c .eq. '-')) X 1 then X Call dtcdtinc XC (line,Incmod) X if (ln1 .ne. 0) go to 450 XC something left, schedule it X X ln1c = incsel(incmod) XC Phony line X line(2) = 0 XC End-of-line ? X comlen = 1 X go to 1111 XC Display based on incr X Xc reverse display flag so we hunt up free slots... note week, month Xc routines all get hacked on to do this... Xc reparse line after copying it down 1 character to remove the 'N' X else if (ln1c .eq. 'N') X 1 then X rdspfg=1 X call shrink(1, ifnb, lnb) X go to 1111 X X else if (ln1c .eq. 'P') X 1 then XC Purge old appointments X call strip XC (line) X go to 6 X X else if ((ln1c .eq. 'U') .or. (ln1c .eq. 'X')) X 1 then X call strip XC (line) XC Cancel or reschedule X if (ln1c .gt. ' ') go to 1 XC Re-scan if leftover chars X go to 6 X X else if (ln1c .eq. 'L') X 1 then Xc for locating free time, use week function and scan map X ctlfg=1 X ln1c='W' X incmod=2 X call week XC (line) X go to 6 X X else if (ln1c .eq. 'T') X 1 then X ln1c='D' X incmod=1 X call day XC (line) XC today's memos then exit X go to 999 X X else if (ln1c .eq. 'R') X 1 then X ln1c='W' X incmod=2 X call week XC (line) XC remind one of this week X go to 999 X X else if (ln1c .eq. 'C') X 1 then XC calendar print for month X incmod=3 X call month XC (line) X go to 999 X X else if (ln1c .eq. 'I') X 1 then XC Reset default date X call dtcicomd XC Process possible date string X go to 6 XC (for testing mods) X X else if ((ln1c .eq. 'H') .or. (ln1c .eq. '?')) X 1 then X call dhelp XC HELP XC (instructions) X go to 6 X Xc f filename enters new default data file name to use... X else if (ln1c .eq. 'F') X 1 then X call shrink(1,ifnb, lnb) X if (ifnb .eq. 0) X 1 then X fnamech = 'DTC.DAT' X fnsz = 7 XC Length of default value X else X do (i=1,lnb) X fname(i)=line(i) X end do X fnsz=lnb X end if X fname(fnsz+1)=0 XC Make FORTRAN OPEN happy X go to 6 X X else if ((ln1c .eq. 'Q') .or. X 1 ((line(1).eq.ichar('E').or.line(1).eq.ichar('e')).and. X 2 (line(2).eq.ichar('X').or.line(2).eq.ichar('x')))) then X go to 999 XC Exeunt omnes X X else X XC Now get a bit fancy: (play with the line string) Xc X if (ln1c .eq. 'E') go to 450 Xc X If (.not. numeric(ln1)) go to 5 XC unknown Xc X 450 continue XC From E above, or leftovers for +/- XC The first character is a number or E, Xc call the daily appointment subroutine: X X incmod=1 X line(icmln) = 0 XC Tag e/o/l X call day XC (line) X go to 6 X X End If Xc X 5 continue XC First character not recognized X Xc Line was uninterpretable, so display menu: X X 77 call menu XC Also display menu first time if no command X X 6 continue XC get a new line and hop back up... X if (exflag) go to 999 XC DEBUG: Display remains of line after operations on it XC XC iln = 1 Xc XC do i = 1, icmln Xc XC if (line(i) .eq. 0) line(i) = O'32' XC control Z, displays as BLOT Xc XC if (line(i) .gt. ' ') iln = i Xc XC end do Xc XC WRITE(iterm,93) (line(i), i= 1, iln) Xc XC 93 format(' ', <iln>a1, ': DTC: ',$) X call dtcat(1,22) X Rewind iterm X write(iterm,93) X 93 format(/,' DTC: ',$) X Rewind iterm Xc --- comlin = ' ' XC Initialize w/ blanks X Rewind 7 X read (7, 7, end=999) comlin X X Rewind 7 X 7 format(a) X Do 750 n=1,80 X nnn=81-n X comlen=nnn X if(comlin(nnn:nnn).gt.' ')goto 751 X comlin(nnn:nnn)=char(0) X750 continue X751 continue X Xc Mark only stuff read from terminal Xc (don't want command-input call to try to read terminal) X X line(min0(comlen+1, icmln)) = 0 XC mark for old-style tests X X go to 1 X X 999 continue XC EXit, Quit, or ^Z X stop X end XC -h- dtcdatinc.for Tue Jul 8 16:07:46 1986 X Subroutine dtcdtinc XC (Line,Incmod) X Xc routine to add or subtract sidereal units (days, weeks, months or years) X Xc incmod = 1 for day (in COMMON) Xc = 2 for week Xc = 3 for month Xc = 4 for year X Xc format is Xc +nn or -nn : add/subtract nn default units Xc +/- nnu (u=d,w,m,y) to add/subt that unit X Xc output in defdat X X include comdtc.INC X X INTEGER*1 ln1, ll X Character*1 ln1c Xc ml is 14 long to allow refs out of bounds to l for no. days in month... X XC length of months - Dec, Jan ... Dec, Jan X Integer*4 l(12), ml(14) X X equivalence (l(1), ml(2)), (line, ln1) X Equivalence(ln1,ln1c) X include stmtfuncsp.for X include comdtcd.inc X X Data ml /31, 31,28,31, 30,31,30, 31,31,30, 31,30,31, 31/ X include stmtfunc.for X Xc Begin code X X l(2) = 28 XC Initialize (may have been changed below) X X isign=1 XC Called only if + or - is first char of LINE X if (ln1c .eq. '-') X 1 isign = -1 X Xc now grab off digits... X X magn=0 XC Initialize magnitude of value X X do (n = 2, icmln) X ll = line(n) X if (.not.( numeric(ll))) go to 5 XC Exit first non-numeric X magn = (magn * 10) + icvtbn1(ll) X end do X X n = icmln XC This many numeric, no overflow??? X X 5 continue X X if (magn .eq. 0) X 1 magn = 1 X X if (alpha(ll)) X 1 then X X ll = ll .and. ucmask X Xc scan for d,w,m,y for units X X if (ll .eq. ichar('D')) X 1 then X incmod=1 X else if (ll .eq. ichar('W')) then X incmod=2 X else if (ll .eq. ichar('M')) then X incmod=3 X else if (ll .eq. ichar('Y')) then X incmod=4 X else X n = n - 1 XC Don't strip one we didn't use: alpha X end if X X else X X n = n - 1 XC Don't strip one we didn't use: non-alpha X X end if X X call shrink(n, ifnb, lnb) XC Shift LINE over X Xc magn now has magnitude, isign has sign and incmod has type of increment. X X if (incmod .le. 2) X 1 then X inctyp = 1 X Xc adjust weeks as being 7 * days and treat together X X if (incmod .eq. 2) X 1 magn = magn * 7 X X else X inctyp = incmod - 1 X X end if X Xc inctyp is 1 for day or week, 2 for month, 3 for year X X if (inctyp .eq. 1) X 1 then XC Moving by days X iddy = iddy + (isign * magn) X Xc loop point if we move forward X X 100 if (iddy .gt. l(idmo)) X 1 then X X lyd = 0 X Xc account for leap years where february is 29 days long... X X if (islpyr(ibigyr) .and. (idmo .eq. 2)) X 1 lyd = 1 X X iddy = iddy - l(idmo) - lyd X idmo = idmo + 1 X X if (idmo .gt. 12) X 1 then X idmo = 1 X ibigyr = ibigyr + 1 X end if X X goto 100 X X end if X Xc loop point if we move back X X 110 if (iddy .le. 0) X 1 then X Xc account for leap years. note ml is prev month so check def mo = 3 X X lyd = 0 X if (islpyr(ibigyr) .and. (idmo .eq. 3)) X 1 lyd = 1 X X iddy = iddy + ml(idmo) + lyd X idmo = idmo - 1 X if (idmo .le. 0) X 1 then X idmo = 12 X ibigyr = ibigyr - 1 X X end if X X goto 110 X X end if X X else if (inctyp .eq. 2) then XC moving by months X X idmo = idmo + (isign * magn) X X 200 if (idmo .gt. 12) X 1 then X X idmo = idmo - 12 X ibigyr = ibigyr + 1 X X goto 200 X X end if X X 300 if (idmo .le. 0) X 1 then X X idmo = idmo + 12 X ibigyr = ibigyr - 1 X X goto 300 X X end if X X else if (inctyp .eq. 3) then X ibigyr = ibigyr + (isign * magn) X X end if X X if (inctyp .ge. 2) XC months or years X 1 then XC Must check if we exceed month length X X if (islpyr(ibigyr)) X 1 then X l(2) = 29 X else X l(2) = 28 X end if X X iddy = min0(iddy, l(idmo)) XC force last day of month, if necessary X X end if X X idyr = mod(ibigyr, 100) XC Restrict to current 'century' X X end X XC -h- menu.for Tue Jul 8 16:02:05 1986 Xc----------------------------------------------------------------------- XC Menu subroutine XC part of Mitch Wyle's DTC program XC Inputs: Xc None XC Output: Xc display screen (see below) XC----------------------------------------------------------------------- Xc X X SUBROUTINE menu X XC Declarations: Xc X X include comdtc.INC XC Need ITERM X include escdtc.INC XC INTEGER*1 esc /27/ Xc Integer*4 iterm/6/ X include comdtcd.inc X include escdtcd.inc X XC Initialize: Xc X Xc iterm = 6 XC Output terminal unit number Xc esc = O'033' X Xc call dtcat(1,1) X Rewind iterm X write(iterm,1) esc,homescrn, esc,clrscrn XC clear screen X 1 format($,4a, $) Xc X write(iterm,2) ' ', esc,dhdw1 XC double-height X 2 format($,3a,13X,'D T C C o m m a n d s') XC .. Xc write(iterm,2) ' ', esc,dhdw2 XC double-width Xc X write(iterm,3) X 3 format(/,1x, X 1 8x,'D [mmddyy] - Appointment Schedule for dd mm yy',/, X 2 8x,'W [mmddyy] - Week-At-A-Glance for week of dd mm yy', X 3 /,8x,'M [mmyy] - Month-At-A-Glance for mm yy',/, X 4 8x,'Y [yy] - Full Year calendar for yy',/, X 5 8x,'+ or - nnZ - Add/Subt nn Z (Z=D,W,M,Y): change date', X 5 /, X 6 8x,'N(cmd str) - Reverse display sense of M or W cmd', X 6 ' (free time)',/, X 7 8x,'L [mm]dd[yy] n - Locate time (n * 30 mins.) free for mtg') X Write(iterm,303) X303 format( X 8 8x,'hh:mm>hh:mm - Add or change appointments for hh:mm',/, X 9 8x,'EV (pseudo time) - Add or change EVening appointment',/, X 1 8x,'P [mmddyy] - Purge appointments prior to mmddyy',/,8x, X 2 'U [mmddyy] t1[>t2] <cmd> - Unschedule (cancel) appointments',/, X 3 8x,'X d1 t1 d2 t2 <cmd> - eXchange (reschedule) appointments',/, X 3 8x,' (then execute <cmd> if present)', /, X 4 8x,'S [mmddyy] - Schedule multiple activity on mmddyy',/, X 4 8x,' (Drops notices in all indirected users files also)',/, X 5 8x,'G [mmddyy] - File activities in multiple files',/, X 6 8x,'F FILENAME - Change default data file to Filename',/, X 7 8x,'I - Reset default date to today.',/, X 8 8x,'H or ? - Help!',/, X 9 8x,'Q, EX, or ^Z - Exit') XC After all that X Rewind iterm Xc X return Xc X end XC -h- dtcidate.for Tue Jul 8 16:02:23 1986 X subroutine dtcidate (imr, idr, iyr) XC Testing aid for DTC - allows for phony value of current date to be Xc returned to caller, for verifying displays, etc XC Calling sequence - same as Fortran IDATE Xc X include comdtc.INC X include dtcxidate.INC X include defcentry.INC X include escdtc.inc X include comdtcd.inc X include escdtcd.inc Xc X if (xim .eq. 0) then XC Assumes linker initializes to zero X X call date (xim, xid, xiy) X if(xiy.gt.100)xiy=mod(xiy,100) X xibgyr = icntry + xiy X if(xibgyr.lt.100)xibgyr=xibgyr+1900 XC Set long value X X end if X X imr = xim X idr = xid X iyr = xibgyr X X end X subroutine dtcicomd XC Process "I" command: if no arguments, reset dummy IDATE to current date, Xc else call dtcdatcvt to parse a date string, store those values in Xc XIDATE common. X X include comdtc.INC X include dtcxidate.INC X include escdtc.inc X include defcentry.INC X X INTEGER*1 ln1 X Character*1 ln1c X equivalence (line(1), ln1) X equivalence(ln1,ln1c) X X include comdtcd.inc X include escdtcd.inc X X X call shrink(1, ifnb, ilnb) XC Unload command character X X if (ln1 .eq. 0) X 1 then X X call date (xim, xid, xiy) X if(xiy.gt.100)xiy=mod(xiy,100) X xibgyr = icntry + xiy X if(xibgyr.lt.100)xibgyr=xibgyr+1900 XC Reset X Xc xibgyr = icntry + xiy XC Set long value X X ibigyr = xibgyr XC Set values into common X X idmo = xim X iddy = xid X idyr = xiy X X else X X call dtcdatcvt (3) XC Parse string X X xim = idmo XC Set test values X xid = iddy X xiy = idyr X X xibgyr = ibigyr X X end if X X end XC -h- dtcrdappt.for Tue Jul 8 16:02:38 1986 X subroutine dtcrdappt (eofflg, indflg) X Xc search through appointment files for entries matching range of hash values. Xc opens files if EOFFLG set on entry. INDFLG controls whether indirect files Xc should be opened as encountered, and whether caller wants to look at indirect Xc entry or not: X Xc INDFLG Xc -1 No processing @ Xc 0 Normal processing Xc +1 Return before opening @ X Xc EOFFLG Entry Exit Xc -1 Initialize EOF return Xc 0 Normal re-entry Normal return, valid entry Xc +1 Open @ file Return for @ filename found X Xc Processes both old- and new-format files Xc Old: yymmddhhh appt (possibly no blank between HHH & APPT) Xc New: yyyymmddhhhh appt X Xc Created 19850802, CG, using some code removed from DAY subroutine X Xc implicit none X X Integer*4 eofflg, indflg XC i/o, i only X X include comdtc.INC X include apptdtc.INC X include defcentry.INC XC Default century for old format X include escdtc.inc X character*1 nullch XC Old old files had trailing NULs X include stmtfuncsp.for X Integer*4 i, ij, lth, istrend, nunit X X Data nullch/0/ X include comdtcd.inc X include escdtcd.inc X include stmtfunc.for X Xc Begin code X Xc *** type 950, irqhash Xc 950 format(2z9.8) X X if (eofflg .lt. 0) XC Start scan X 1 then X X nunit=1 X close(1) X Open (unit=nunit, file=FNc(1:fnsz), X 1 status='OLD',action='READ', X 1 form='FORMATTED', err=99) X X eofflg = 0 Xc *** type *, ' Opened file' X end if X Xc loop back up here to continue reading and processing input file: X X do while (eofflg .ge. 0) X X 900 format( a) XC Read all X 901 format(3i2, i3) XC Decode old X 902 format(i4, 2i2, i3) XC Decode new X X if (eofflg .gt. 0) X 1 then XC must open indirect file X X eofflg = 0 X Xc *** type 951, work(istart) Xc *** 951 format (' ', a) X Do (nnn=1,80) X ilst=81-nnn X if(workstr(ilst:ilst).gt.' ') goto 952 Xc find index of end string (last nonspace char) X End Do X952 continue X nunit = 2 X close(2) X Open (unit=nunit, file=workstr(istart:ilst), status='old', X 1 form='formatted', action='READ', X 2 err=1067) X X end if X X read (nunit, 900, end=400,err=400) workstr Xc find lth now by hand Xc assume 80 char work array max X do 705 i705=1,80 X lth=81-i705 X if(workstr(lth:lth) .gt. ' ') goto 706 X workstr(lth:lth)=nullch X705 continue X706 continue Xc *** type *, ' ', workstr XC Look for non-blank XC & non-null X do (i = min0(lth, iwrkln), 1, -1) X if ((workstr(i:i) .ne. ' ') X 1 .and. (workstr(i:i) .ne. nullch)) X 2 go to 10 XC Break X end do X X i = 1 XC All blank entry ??? X X 10 lth = i X Xc String is filled with blanks regardless of length of record X X if (chnumeric(workstr(10:10))) X 1 then XC new format X read(workstr, 902, err=30) ihy, ihm, ihd, iht X istart = 12 XC Index of first valid character Xc *** type *, ' New format' X X else XC Old format X X 30 continue XC Retry old X read(workstr, 901, err=300) ihy, ihm, ihd, iht X ihy = ihy + icntry XC Insert current century X X istart = 10 XC Assume old, old format X Xc *** type *, ' Old format' X X end if XC (workstr(10) is numeric) X X if (workstr(istart:istart) .eq. ' ') X 1 istart = istart + 1 XC Index of first valid character X X iwkln = max0((lth - istart) + 1, 1) X istrend = (istart + iwkln) - 1 X iaptln = max0(min0(iwkln, icmln), 1) X X if (ihm .eq. 99) X 1 then X X ihy = 9999 XC set all fields X ihd = 99 X iht = 999 X X if ((indflg .ge. 0) .and. (nunit .eq. 1)) X 1 then X X call fnscan(work(istart), icmln - istart + 1, X 1 iwkln, ij) XC Common code to check filename X X if (ij .ne. 0) X 1 then XC Skip if no file X Xc *** type *, ' IJ = ', ij X eofflg = 1 X X if (indflg .gt. 0) X 1 then X X apptstr = workstr(istart:istrend) X X return XC DAY, STRIP want a look X X end if XC Found 1 X X end if XC non-null file-name X X end if XC valid place for indirect X X else XC not filename flag in record X X irchash = ihymd(ihy, ihm, ihd) XC Compute hash for record X Xc *** type 950, irchash X X if ((irchash .ge. irqhash(1)) X 1 .and. (irchash .le. irqhash(2))) X 2 then XC Found record within range, exit X X apptstr = workstr(istart:istrend) X Xc *** type *, ' Returning' X return XC Break out of loop X400 continue XC no more appointments left in file. Xc *** type *, ' EOF' X if (nunit .eq. 1) X 1 then XC Which file were we reading? X eofflg = -1 XC real end of file X else X1067 close (2) XC Error opening indirect file X nunit=1 X end if XC Which unit had EOF X end if XC Hash range test X end if XC type of record X300 continue XC Error decoding y/m/d/t fields X end do XC Read next line from current file X close (1) XC Close first-level X99 continue XC Failed first open X end XC -h- dtcmthnam.for Tue Jul 8 16:03:02 1986 X SUBROUTINE dtcmthnam (im,monthn) Xc----------------------------------------------------------------------- XC Subroutine dtcmthnam (formerly GABY) XC Part of Mitch Wyle's DTC program XC return a string corresponding to the month number Xc Month number contained in IM. Send back string in MONTHN. Xc (JANUARY for 1, etc.) XC----------------------------------------------------------------------- XC Modified 850315 - Center month names in table, use mixed case - CG Xc Modified 850802 - Renamed DTCMTHNAM X XC Declarations: Xc X INTEGER*1 monthn(9) Xc *** character*9 monthn XC Can't use, char params expect descriptor X XC Table of month names and numbers (centered, even lengths biased left): Xc X X INTEGER*1 months(9,14) X character*9 monthch(14) X X equivalence (months, monthch) XC Select the right month and fill monthn with it: X Data monthch/ 'December ', X 1 ' January ', 'February ', ' March ', ' April ', X 2 ' May ', ' June ', ' July ', ' August ', X 3 'September', ' October ', 'November ', 'December ', X 4 ' January '/ X Xc X XC ALLOW FOR OVERFLOWS... X IMM=IM+1 Xc *** monthn = monthch(imm) XC String assignment Xc X Do (i=1,9) XC byte-at-a-time X Monthn(i) = months(i,imm) X end do X Xc All done. X X end XC -h- dtcalcdow.for Tue Jul 8 16:03:26 1986 X SUBROUTINE dtcalcdow(ib,il,im,iyx) Xc----------------------------------------------------------------------- XC DTCALCDOW subroutine XC part of Mitch Wyle's DTC program XC Inputs: Xc im - month (number 1-12) Xc iy - year (number 0-9999) XC Outputs: Xc ib - integer corresponding to day of week Xc on which the month begins (1-7) Xc il - length of the month in days XC Modified 850117 by CG because it thought New Years 1985 was on Monday Xc when it really was on Tuesday (not counting intervening Xc leap years between 1982 and current as having 366 days). Xc Modified 850724 by Glenn Everhart to work for years between 1900 Xc and 1982 (formerly thought all intervening years started Xc on Friday) Xc Modified 850726 by CG to simplify days-since-base calculation. Xc NOTE: Has been reworked to calculate all dates AS IF Xc the Gregorian Calendar had been in effect since AD 1, Xc and that the Gregorian correction for 100 and 400 Xc will be valid indefinitely (the 1928 Episcopal Xc Book of Common Prayer indicates this is valid at least Xc until AD (or CE) 8400, but I don't think I, or anybody Xc reading this code within the forseeable future will be Xc around to verify whether it does or doesn't!), see note Xc just before IDAYS computation. It will also try to compute Xc if a negative year is input (i.e., BC) but probably won't be Xc valid since there was no year zero. If any calendar phreak Xc wants to figure it out for the Julian calendar, have fun, Xc just keep in mind that the Gregorian superseded the Julian Xc at different times and in different ways in different localities Xc (October 4, 1582 was followed by October 15 in Catholic Xc countries, and another "long sleep" occurred in September 1752 Xc in English-speaking realms, but apparently in Sweden Xc the change was effected by omitting Leap Years Xc until the calendar got back in sync Xc (there is a story of a man who didn't celebrate his first Xc birthday until he was sixty years old, leaving Frederic Xc of Pirates of Penzance with little to complain about) XC Russia, Romania, Greece and Turkey did not convert until Xc the twentieth century. XC P.S.: 4th parameter (input year) is no longer modified. XC Modified 850729 by CG - Get rid of loop that added number of days of Xc each month --- why sum a sequence of constants? Xc Modified 850802 by CG - renamed from DANY to DTCALCDOW, removed Xc default century and previously commented-out code Xc Modified 850809 by CG - Insure IB output in range 1..7: negative values Xc (from negative year input) caused DTCDSPMTH to zap its Xc character arrays and display some verrry strange-looking months XC----------------------------------------------------------------------- Xc Xc Declarations: Xc Base value for IDAYS, day-of-week for January 1, AD 1 XC X parameter (idow = 2) X Integer*4 im XC Julian Month X Integer*4 iyx, iy XC Julian Year X Integer*4 lpyear XC Define additive variable X include stmtfuncsp.for Xc Array of months and number days X Integer*4 months(12) XC in each one Xc array of months containing d/o/w X Integer*4 bomdow(12) XC of first day of month X X Data months X 1 /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ XC in each one X Xc array of months containing d/o/w X data bomdow X 1 / 0, 3, 3, 6, 1, 4, 6, 2, 5, 0, 3, 5 / XC of first day of month X include stmtfunc.for XC Need ISLPYR function Xc Xc Begin code Xc X iy = iyx XC Copy parameter Xc Take care of leap years: X lpyear = 0 XC Assume "common" year X if (islpyr(iy)) X 1 then X months(2) = 29 XC length of February in leap year X if (im .gt. 2) lpyear = 1 XC Add one to BOM DOW after Feb X else X months(2) = 28 XC .. "common" year X end if X Xc Rather than add up all of the days since January First, AD 1 Xc (which would have been a Monday had the Gregorian calendar been in effect then), Xc we note that the day of week of 1 January advances by 1 day per year, Xc plus another day the year AFTER a leap year, etc, therefore just add Xc values of years, leap years, century years, etc, modulo 7, to figure out Xc day of week of the month we are interested in. X X itemp = iy - 1 XC not including current year XC Day of week of 1/1/0001 XC plus number of years XC plus number of leap years XC less even hundreds XC but add back even four hundreds XC plus day of week for BOM X idays = idow X 1 + itemp X 2 + (itemp/4) X 3 - (itemp/100) X 4 + (itemp/400) X 5 + bomdow(im) X 6 + lpyear XC plus 1 for March or later in leap year X X ib = mod ( idays , 7 ) XC Find day of week 0:6 X if (ib .le. 0) ib = ib + 7 XC In case IY was negative (Sun is day 1) X il = months(im) XC Length of the current month X X end XC -h- dtcdspmth.for Tue Jul 8 16:03:45 1986 X SUBROUTINE dtcdspmth (ib,il,xoff,xspa,YOFF,yspa) X Xc----------------------------------------------------------------------- XC DTCDSPMTH month printing subroutine (formerly MISCHY) XC part of Mitch Wyle's DTC program XC Inputs: Xc ib - begining day of the week Xc il - length of month in days Xc xoff - offset for x coordinate Xc xspa - number of spaces to skip between numbers Xc yoff - offset for y coordinate Xc yspa - number of lines to skip between lines XC Output: Xc display screen (see below) XC Modified 850301, CG - write full line at a time, rather that each date Xc Modified 850802, CG - Renamed from mischy XC----------------------------------------------------------------------- Xc X Xc Declarations: X X Integer*4 ib XC beginning day of the week X Integer*4 il XC length of month in days X Integer*4 xoff XC x offset X Integer*4 xspa XC number of spaces between numbers X Integer*4 yoff XC y offset X Integer*4 yspa XC number of lines to skip between lines X X include comdtc.INC XC Need ITERM X include escdtc.INC X X Integer*4 ix XC x coordinate of where to put day X Integer*4 iy XC y coordinate of where to put day X Integer*4 ip XC the day of the week for date in hand X Integer*4 ixo XC xoff + 1 X Xc numbers as characters X Integer*2 nums(31) X Integer*2 wknums(7) Xc 1 format('+',6(a2,<ix>x),a2) X Character*1 nmfmt(18) X Character*2 nmff X Character*18 nmfm X Equivalence(nmfm,nmfmt(1)),(nmfmt(10),nmff) X Data nmfm/'($,6(1A2,01X),1a2)'/ X Data nums X 1 / ' 1', ' 2', ' 3', ' 4', ' 5', ' 6', ' 7', ' 8', ' 9', X 2 '10', '11', '12', '13', '14', '15', '16', '17', '18', '19', X 3 '20', '21', '22', '23', '24', '25', '26', '27', '28', '29', X 4 '30', '31'/ X X include comdtcd.inc X include escdtcd.inc XC To contain copies of above, or blanks X Xc Begin code X X do (i = 1, 7) XC One week's worth X wknums (i) = ' ' XC initialize X end do X ip = ib X ix = xspa + 1 XC Used in format # 1 X ixo = xoff + 1 X iy = 4 + YOFF X Xc Now write month out to screen, one week at a time: X X Do (i = 1, il) X X wknums(ip) = nums(i) XC Get day as character X If ( ip .eq. 7 ) XC is it Saturday again? X 1 then X call dtcat(ixo,iy) XC Position cursor for line X write(nmff,110)ix X Rewind iterm X write(iterm,nmfm)wknums X Rewind iterm Xc write (iterm,1) wknums XC Write filled array X ip = 1 XC reset day to Sunday. X iy = iy + 1 + yspa XC move down one line X else X ip = ip + 1 XC increment day number X End If X X end do X X if (ip .ne. 1) XC Partial buffer remains X 1 then X X call dtcat(ixo,iy) XC Position cursor X Rewind iterm Xc write (iterm,1) (wknums(i), i = 1, ip - 1) X write(nmff,110)ix X110 format(i2.2) X write(iterm,nmfm)(wknums(i),i=1,ip-1) X1 format($,a2,1x,$) X Write(iterm,223) X223 format(/,1x) X Rewind iterm Xc emit trailing crlf... XcC Write rest of array X end if X Xc 1 format('+',6(a2,<ix>x),a2) X end XC -h- dhelpvax.for Tue Jul 8 16:04:30 1986 Xc----------------------------------------------------------------------- XC Help subroutine XC part of Mitch Wyle's DTC program XC Inputs: Xc None XC Output: Xc display screen (see below) XC----------------------------------------------------------------------- Xc X X SUBROUTINE dhelp X X include comdtc.INC X include escdtc.INC Xc X Xc Integer*4 iterm/6/ Xc INTEGER*1 esc/O'033'/ X INTEGER*1 buf(79) X include comdtcd.inc X include escdtcd.inc X XC Initialize: Xc X Xc iterm = 6 XC Output terminal unit number Xc esc = o'033' X X call dtcat(1,1) X Rewind iterm X write(iterm,91) esc,homescrn, esc,clrscrn XC clear screen X write(iterm,1) ' ', ' D T C - Desk Top Calendar' Xc write(iterm,1) ' ', esc,dhdw2, ' D T C - Desk Top Calendar' Xc X 1 format(40a) X 91 format($,4a, $) X X Open (unit=1,file='DTC.HLP',action='READ',form='FORMATTED', X 1 status='OLD', err=9) X X Do (i=1, 22) X Read(1,4,end=5) buf X do 301 n=1,78 X ibln=79-n X if(buf(ibln).gt.32)goto 302 X buf(ibln)=0 X301 continue X302 continue X if (ibln .ne. 0) then X write (iterm,6) (buf(j), j=1,ibln) X else X write (iterm,6) X end if X end do Xc X 4 format(100a1) X 6 format(1x,100a1) Xc X 5 close(unit=1) XC Read end-of-file X Rewind iterm X return Xc X 9 write(iterm, 99) X 99 format(' Help file C:DTC.HLP not found') X Rewind iterm X Return X end XC -h- day.for Tue Jul 8 16:04:45 1986 Xc----------------------------------------------------------------------- XC Daily Appointment subroutine XC part of Mitch Wyle's DTC program XC Input: Xc line - 72 INTEGER*1s; Format: D [mmddyy [hh:mm>HH:MM [appointment]]] XC Output: Xc display screen (see below) XC----------------------------------------------------------------------- XC Modified 850314, CG, to write day-of-week to daily-appointment screen, Xc and note current time if current day displayed (reverse video) Xc Modified 19850802, CG, to write full date as well, and handle both new- Xc and old-format appointment files. Xc Modified 851218, CG: change default range of appointment from whole day Xc to 8:00 only XC Modified 860220, CG: Check for duplicate appointment times, Xc move and flag them X X SUBROUTINE day XC (line) X Xc Declarations: X X include comdtc.INC X include apptdtc.INC X include escdtc.INC X X character*100 apstr X INTEGER*1 appnt(icmln) XC appointment string X INTEGER*1 temp(2), ll, ln1, ap1 X Character*1 ln1c XC temporary string converting array X X INTEGER*1 blot XC ^Z, for entry from display X X Integer*4 id, idr XC Julian Day X Integer*4 im, imr XC Julian Month X Integer*4 iye, iyr XC Julian Year X Integer*4 idx, imx, iyx, isx XC copies for calling DANY X integer*1 ibsp X Integer*4 eofflg X XC uses A6 fmt XC 'day' is in format X real*8 daylist(7) X character*9 mthlist(12) X X character*22 dupl XC only 3:22 used X INTEGER*1 dupb(22) X Integer*4 iscnds X equivalence (line, ln1), (apstr, appnt),(apstr, ap1), X 1 (dupl, dupb) X character*1 blotc X equivalence(blot,blotc) X Equivalence (ln1,ln1c) X include stmtfuncsp.for X data blotc/'_'/ X include comdtcd.inc X include escdtcd.inc X END_OF_FILE if test 38412 -ne `wc -c <'Dtc.For.aa'`; then echo shar: \"'Dtc.For.aa'\" unpacked with wrong size! fi # end of 'Dtc.For.aa' fi echo shar: End of archive 5 $of 6$. cp /dev/null ark5isdone MISSING="" for I in 1 2 3 4 5 6 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 6 archives. rm -f ark[1-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0 -- Mail submissions (sources or binaries) to <amiga@cs.odu.edu>. Mail comments to the moderator at <amiga-request@cs.odu.edu>. Post requests for sources, and general discussion to comp.sys.amiga.